home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
Tech Arsenal 1
/
Tech Arsenal (Arsenal Computer).ISO
/
tek-02
/
faq-s.zip
/
SUBS2.PAS
< prev
next >
Wrap
Pascal/Delphi Source File
|
1991-05-04
|
58KB
|
2,204 lines
{$R-,S-,I-,D-,F+,V-,B-,N-,L+ }
{$M 65500,0,0 }
unit subs2;
{ $define testingdevices} { Activate this define for test mode }
interface
uses printer,dos,crt,overlay,gentypes,configrt,gensubs,subs1,windows,modem,
video,textret,mailret,statret,chatstuf,flags,userret;
procedure clearscr;
procedure replace (var main:anystr; old,new:anystr);
procedure beepbeep;
procedure summonbeep;
procedure abortttfile (er:integer);
procedure openttfile;
procedure writecon (k:char);
procedure toggleavail;
{procedure domacro (sussuh:anystr);}
function charready:boolean;
function readchar:char;
function waitforupchar:char;
function waitforchar:char;
procedure clearchain;
function charpressed (k:char):boolean; { TRUE if K is in typeahead }
procedure addtochain (l:lstr);
procedure directoutchar (k:char);
procedure handleincoming;
procedure writechar (k:char);
{F+}
function opendevice (var t:textrec):integer;
function closedevice (var t:textrec):integer;
function cleardevice (var t:textrec):integer;
function ignorecommand (var t:textrec):integer;
function directoutchars (var t:textrec):integer;
function writechars (var t:textrec):integer;
function directinchars (var t:textrec):integer;
function readcharfunc (var t:textrec):integer;
{F-}
function getinputchar:char;
procedure getstr (mode:integer);
procedure writestr (s:anystr);
procedure printxy (x,y:integer;str:anystr);
procedure printxy2 (x,y:integer;str:anystr);
procedure cls;
procedure writehdr (q:anystr);
function issysop:boolean;
{function islz:boolean;}
procedure reqlevel (l:integer);
procedure printfile (fn:lstr);
{procedure print_the_stats (fn:lstr);}
procedure show_all_info (fn:lstr;dernier:mstr;nombre:integer);
procedure printtexttopoint (var tf:text);
procedure skiptopoint (var tf:text);
function minstr (blocks:integer):sstr;
procedure parserange (numents:integer; var f,l:integer);
function menutype:integer;
function menu (mname:mstr; mfn:sstr; choices:anystr):integer;
procedure menuname (menunme:lstr);
function checkpassword (var u:userrec):boolean;
function getpassword:boolean;
procedure getacflag (var ac:accesstype; var tex:mstr);
procedure calcqr;
procedure overlayerror;
function parsedate (date:anystr):lstr;
function ansi:boolean;
function ascii:boolean;
procedure setmenutype;
procedure movexy (x,y:integer);
procedure ansicls;
{procedure idiot;}
procedure showcredits;
procedure ansi_window (xx,yy,xxx,yyy:integer);
procedure write_menu (x,y:integer; c,s:string);
procedure pause;
implementation
procedure clearscr;
begin
if (ansigraphics in urec.config) then
write (direct,#27+'[2J') else
write (^L);
end;
procedure replace (var main:anystr; old,new:anystr);
var p : byte;
begin
repeat
p := pos (old,main);
if p <> 0 then
begin
delete (main,p,length(old));
insert (new,main,p)
end
until p = 0;
end;
{procedure beepbeep;
begin
nosound;
sound (200);
delay (50);
nosound
end;}
procedure beepbeep;
begin
nosound;
sound (200);
delay (20);
nosound
end;
procedure summonbeep;
var cnt:integer;
begin
nosound;
cnt:=1330;
repeat
sound (cnt);
delay (10);
cnt:=cnt+200;
until cnt>4300;
nosound
end;
procedure abortttfile (er:integer);
var n:integer;
begin
specialmsg ('Texttrap error '+strr(er)+'.');
texttrap:=false;
textclose (ttfile);
n:=ioresult
end;
procedure openttfile;
var n:integer;
begin
appendfile (bbsdatadir+'Texttrap.dat',ttfile);
n:=ioresult;
if n=0
then texttrap:=true
else abortttfile (n)
end;
function scramble (s:char):char;
var f:text;
x,y:char;
z:integer;
begin
scramble:=s;
if noscramble then exit;
if not scrambled then exit;
if not exist (faqdir+'Scramble.Dat') then exit;
if not (ord(s) in [65..90,97..122]) then exit;
assign (f,faqdir+'Scramble.Dat');
reset (f);
for z:=1 to ord(s) do
read (f,x);
scramble:=x;
close (f);
end;
procedure overridescramble;
begin
if scrambled then begin
scrambled:=false;
end else
if not scrambled then begin
scrambled:=true;
end;
textcolor (12);
writeln (usr);
writeln (usr);
beepbeep;
writeln (usr,'┌─────────────────────────────┐');
write (usr,'│ == ');
textcolor (9);
write (usr,'Data Scramble Override!!');
textcolor (12);
writeln (usr,' │');
write (usr,'│ == ');
textcolor (10);
write (usr,'Data Scramble is now:');
textcolor (11);
if scrambled then write (usr,'ON ') else
if not scrambled then write (usr,'OFF ');
textcolor (12);
writeln (usr,'│');
writeln (usr,'└─────────────────────────────┘');
writeln (usr);
writeln (usr);
textcolor (urec.regularcolor);
end;
procedure togglescreenoutput;
begin
if screenoutput then
screenoutput:=false else
screenoutput:=true;
end;
procedure writecon (k:char);
var r:registers;
kk:char;
begin
if k=^J
then write (usr,k)
else
begin
{ if scrambled then kk:=scramble (k)
else } kk:=k;
r.dl:=ord(kk);
r.ah:=2;
intr($21,r)
end
end;
procedure toggleavail;
begin
if sysopavail=Notavailable
then sysopavail:=available
else sysopavail:=succ(sysopavail)
end;
procedure domacro (sussuh:anystr); forward;
function charready:boolean;
var k:char;
begin
if modeminlock then while numchars>0 do k:=getchar;
if hungupon or keyhit
then charready:=true
else if online
then charready:=(not modeminlock) and (numchars>0)
else charready:=false
end;
function readchar:char;
procedure toggletempsysop;
begin
if tempsysop
then ulvl:=regularlevel
else
begin
regularlevel:=ulvl;
ulvl:=sysoplevel
end;
tempsysop:=not tempsysop
end;
procedure togviewstats;
begin
if splitmode
then unsplit
else
begin
splitscreen (14);
top;
clrscr;
write (usr,'[Level]: ',urec.level,
^M^J'[File Level]: ',urec.udlevel,
^M^J'[File Points]: ',urec.udpoints,
^M^J'[User Note]: ',urec.note,
^M^J'[# Downloads]: ',urec.downloads,
^M^J'[# Uploads]: ',urec.uploads,
^M^J'[# of Posts]: ',urec.nbu,
^M^J'[G-File Ups]: ',urec.nup,
^M^J'[G-File Downs]: ',urec.ndn,
^M^J'[Total Time]: ',urec.totaltime:0:0,
^M^J'[# of Calls]: ',urec.numon);
bottom
end;
end;
type ScreenType = array [0..3999] of Byte;
var ScreenAddr : ScreenType absolute $B800:$0000;
const
HELP_ME_WIDTH=80;
HELP_ME_DEPTH=25;
HELP_ME_LENGTH=1064;
HELP_ME : array [1..1064] of Char = (
#16,#24,#9 ,'┌',#26,#77,'─','┐',#24,'│',' ',#15,'F','A','Q',' ','v',
#11,'1','.','0','0',' ',#15,'P','o','p','-','u','p',' ','H','e','l',
'p',#25,#55,#9 ,'│',#24,'├',#26,#37,'─','┬','┬',#26,#37,'─','┤',#24,
'│',#15,'[','F','1',']',' ','T','w','o','-','W','a','y',' ','C','h',
'a','t',' ','M','o','d','e',' ','w','i','t','h',' ','U','s','e','r',
#25,#5 ,#9 ,'│','│',#15,'[','A','l','t','-','A',']',' ','T','o','g',
'g','l','e',' ','C','h','a','t',' ','A','v','a','i','l','a','b','i',
'l','i','t','y',#25,#5 ,#9 ,'│',#24,'│',#15,'[','F','2',']',' ','L',
'i','n','e',' ','C','h','a','t',' ','M','o','d','e',' ','w','i','t',
'h',' ','U','s','e','r',#25,#8 ,#9 ,'│','│',#15,'[','A','l','t','-',
'T',']',' ','G','r','a','n','t',' ','T','e','m','p','o','r','a','r',
'y',' ','S','y','s','o','p',' ','A','c','c','e','s','s',' ',' ',#9 ,
'│',#24,'│',#15,'[','F','3',']',' ','H','a','n','g',' ','u','p',' ',
'o','n',' ','U','s','e','r',#25,#17,#9 ,'│','│',#15,'[','A','l','t',
'-','K',']',' ','T','a','k','e',' ','a','w','a','y',' ','a','l','l',
' ','T','i','m','e',#25,#11,#9 ,'│',#24,'│',#15,'[','F','4',']',' ',
'Q','u','i','c','k',' ','V','a','l','i','d','a','t','e',' ','C','u',
'r','r','e','n','t',' ','U','s','e','r',#25,#5 ,#9 ,'│','│',#15,'[',
'A','l','t','-','B',']',' ','T','o','g','g','l','e',' ','t','h','e',
' ','S','t','a','t','u','s',' ','B','a','r',#25,#8 ,#9 ,'│',#24,'│',
#15,'[','F','5',']',' ','O','n','-','L','i','n','e',' ','S','y','s',
'o','p',' ','U','t','i','l','i','t','i','e','s',' ','M','e','n','u',
#25,#4 ,#9 ,'│','│',#15,'[','A','l','t','-','E',']',' ','T','o','g',
'g','l','e',' ','T','e','x','t',' ','T','r','a','p',#25,#13,#9 ,'│',
#24,'│',#15,'[','F','6',']',#25,#33,#9 ,'│','│',#15,'[','A','l','t',
'-','V',']',' ','V','i','e','w',' ','C','u','r','r','e','n','t',' ',
'U','s','e','r','s',' ','S','t','a','t','u','s',#25,#4 ,#9 ,'│',#24,
'│',#15,'[','F','7',']',' ','E','x','i','t',' ','t','o',' ','D','O',
'S',' ','a','f','t','e','r',' ','C','a','l','l',#25,#10,#9 ,'│','│',
#15,'[','A','l','t','-','O',']',' ','O','v','e','r','r','i','d','e',
' ','D','a','t','a',' ','S','c','r','a','m','b','l','i','n','g',#25,
#5 ,#9 ,'│',#24,'│',#15,'[','F','8',']',' ','L','o','c','k',' ','t',
'h','e',' ','T','i','m','e',#25,#19,#9 ,'│','│',#15,'[','A','l','t',
'-','D',']',' ','S','h','e','l','l',' ','t','o',' ','D','O','S',#25,
#17,#9 ,'│',#24,'│',#15,'[','F','9',']',' ','L','o','c','k',' ','o',
'u','t',' ','a','l','l',' ','M','o','d','e','m',' ','I','n','p','u',
't',#25,#8 ,#9 ,'│','│',#15,'[','A','l','t','-','F','1',']','-','[',
'A','l','t','-','F','1','0',']',' ','S','y','s','o','p',' ','M','a',
'c','r','o','s',' ','1','-','1','0',' ',' ',#9 ,'│',#24,'│',#15,'[',
'F','1','0',']',' ','L','o','c','k',' ','i','n',' ','a','l','l',' ',
'M','o','d','e','m',' ','O','u','t','p','u','t',#25,#7 ,#9 ,'│','│',
#15,'[','C','t','r','l','-','P','r','t','S','c','r',']',' ','T','o',
'g','g','l','e',' ','P','r','i','n','t','e','r',' ','E','c','h','o',
#25,#4 ,#9 ,'│',#24,'│',#25,#37,'│','│',#15,'[','U',' ','A','r','r',
'o','w',']',' ','I','n','c','r','e','a','s','e',' ','#',' ','o','f',
' ','F','i','l','e',' ','P','o','i','n','t','s',#25,#2 ,#9 ,'│',#24,
'│',#25,#37,'│','│',#15,'[','D',' ','A','r','r','o','w',']',' ','D',
'e','c','r','e','a','s','e',' ','#',' ','o','f',' ','F','i','l','e',
' ','P','o','i','n','t','s',#25,#2 ,#9 ,'│',#24,'│',#25,#37,'│','│',
#15,'[','L',' ','A','r','r','o','w',']',' ','D','e','c','r','e','a',
's','e',' ','T','i','m','e',' ','L','e','f','t',#25,#9 ,#9 ,'│',#24,
'│',#25,#37,'│','│',#15,'[','R',' ','A','r','r','o','w',']',' ','I',
'n','c','r','e','a','s','e',' ','T','i','m','e',' ','L','e','f','t',
#25,#9 ,#9 ,'│',#24,'│',#25,#37,'│','│',#15,'[','H','o','m','e',']',
' ','D','e','c','r','e','a','s','e',' ','M','a','i','n',' ','L','e',
'v','e','l',#25,#11,#9 ,'│',#24,'│',#25,#37,'│','│',#15,'[','P','g',
'U','p',']',' ','I','n','c','r','e','a','s','e',' ','M','a','i','n',
' ','L','e','v','e','l',#25,#11,#9 ,'│',#24,'│',#25,#37,'│','│',#15,
'[','E','n','d',']',' ','D','e','c','r','e','a','s','e',' ','F','i',
'l','e',' ','L','e','v','e','l',#25,#12,#9 ,'│',#24,'│',#25,#37,'│',
'│',#15,'[','P','g','D','n',']',' ','I','n','c','r','e','a','s','e',
' ','F','i','l','e',' ','L','e','v','e','l',#25,#11,#9 ,'│',#24,'└',
#26,#37,'─','┴','┴',#26,#37,'─','┘',#24);
procedure UNCRUNCH (var Addr1,Addr2; BlkLen:Integer);
begin
inline (
$1E/$C5/$B6/Addr1/$C4/$BE/Addr2/$8B/$8E/BlkLen/$8B/$D7/$33/$C0/
$FC/$AC/$3C/$1B/$75/$05/$80/$F4/$80/$EB/$4D/$3C/$10/$73/$07/
$80/$E4/$70/$0A/$E0/$EB/$42/$3C/$18/$74/$13/$73/$19/$2C/$10/
$02/$C0/$02/$C0/$02/$C0/$02/$C0/$80/$E4/$8F/$0A/$E0/$EB/$2B/
$81/$C2/$A0/$00/$8B/$FA/$EB/$23/$3C/$19/$75/$0B/$AC/$51/$32/$ED/
$8A/$C8/$B0/$20/$EB/$0D/$90/$3C/$1A/$75/$0F/$AC/$49/$51/$32/$ED/
$8A/$C8/$AC/$E3/$03/$AB/$E2/$FD/$59/$49/$AB/$E3/$02/$E2/$A5/$1F);
end;
procedure help;
var s:screens;c:char;x,y:byte;
begin
x:=wherex;
y:=wherey;
readscr(s);
cursor (false);
clrscr;
UNCRUNCH(HELP_ME,ScreenAddr[(1*2)+(1*160)-162],HELP_ME_LENGTH);
repeat
c:=#255;
c:=readkey;
until c<>#255;
writescr(s);
gotoxy(x,y);
cursor (true);
end;
procedure showhelp;
begin
help;
end;
procedure toggletexttrap;
var n:integer;
begin
if texttrap
then
begin
textclose (ttfile);
n:=ioresult;
if n<>0 then abortttfile (n);
texttrap:=false
end
else openttfile
end;
procedure printsysopmacro (n:integer);
begin
case n of
1:domacro (sysopmacro1);
2:domacro (sysopmacro2);
3:domacro (sysopmacro3);
4:domacro (sysopmacro4);
5:domacro (sysopmacro5);
6:domacro (sysopmacro6);
7:domacro (sysopmacro7);
8:domacro (sysopmacro8);
9:domacro (sysopmacro9);
10:domacro (sysopmacro10);
end;
end;
var k:char;
ret:char;
linenoise:anystr;
dorefresh:boolean;
iamlaym:byte;
i,cnt:integer;
begin
requestchat1:=false;
requestchat2:=false;
requestcom:=false;
reqspecial:=false;
if keyhit
then
begin
k:=bioskey;
ret:=k;
if ord(k)>127 then begin
ret:=#0;
dorefresh:=ingetstr;
case ord(k)-128 of
availtogglechar:
begin
toggleavail;
chatmode:=false;
dorefresh:=true
end;
doschar:begin
writeln ('Sysop in DOS:');
window (1,1,80,25);
gotoxy (1,25);
writeln (usr,^M^J^J^J);
updateuserstats (false);
execcomcom;
clrscr;
end;
sysopcomchar:
begin
requestcom:=true;
requestchat1:=true;
{requestchat2:=true}
end;
astaline:
begin
writeln;
linenoise:='╬╪╫£¢Θw-s=@%*4';
for cnt:=1 to 8 do write (linenoise[cnt]);
forcehangup:=true;
hangup;
end;
breakoutchar:halt(e_controlbreak);
lesstimechar:urec.timetoday:=urec.timetoday-1;
moretimechar:urec.timetoday:=urec.timetoday+1;
uparrow:urec.udpoints:=urec.udpoints+1;
downarrow:urec.udpoints:=urec.udpoints-1;
leftarrow:urec.timetoday:=urec.timetoday-1;
rightarrow:urec.timetoday:=urec.timetoday+1;
home:ulvl:=ulvl-1;
pageup:ulvl:=ulvl+1;
endkey:urec.udlevel:=urec.udlevel-1;
pagedown:urec.udlevel:=urec.udlevel+1;
leftarrow:urec.timetoday:=urec.timetoday-1;
rightarrow:urec.timetoday:=urec.timetoday+1;
notimechar:settimeleft (-1);
chat1char:requestchat1:=true;
chat2char:requestchat2:=true;
sysnextchar:sysnext:=not sysnext;
timelockchar:if timelock then timelock:=false else begin
timelock:=true;
lockedtime:=timeleft
end;
inlockchar:modeminlock:=not modeminlock;
outlockchar:setoutlock (not modemoutlock);
tempsysopchar:toggletempsysop;
bottomchar:begin
if statusbar then statusbar:=false else statusbar:=true;
bottomline; end;
validate:begin
ulvl:=qvmainl;
urec.udlevel:=qvxferl;
urec.udpoints:=qvxferp;
urec.gflevel:=qvgfile;
urec.note:=qvnote;
cnt:=urec.level;
if cnt<1 then cnt:=1;
if cnt>100 then cnt:=100;
urec.timetoday:=usertime[cnt];
writeurec;
end;
viewstatchar:togviewstats;
sysophelpchar:if dorefresh then showhelp;
texttrapchar:toggletexttrap;
printerechochar:printerecho:=not printerecho;
sm1char:printsysopmacro(1);
sm2char:printsysopmacro(2);
sm3char:printsysopmacro(3);
sm4char:printsysopmacro(4);
sm5char:printsysopmacro(5);
sm6char:printsysopmacro(6);
sm7char:printsysopmacro(7);
sm8char:printsysopmacro(8);
sm9char:printsysopmacro(9);
sm10char:printsysopmacro(10);
phunkey:write (direct,^G);
scroverride:overridescramble;
noscreenoutput:togglescreenoutput;
72:ret:=^E;
75:ret:=^S;
77:ret:=^D;
80:ret:=^X;
115:ret:=^A;
116:ret:=^F;
73:ret:=^R;
81:ret:=^C;
71:ret:=^Q;
79:ret:=^W;
83:ret:=^G;
82:ret:=^V;
117:ret:=^P;
end;
if dorefresh then bottomline
end
end
else
begin
k:=getchar;
if modeminlock
then ret:=#0
else ret:=k
end;
if ret='+' then write (' '^H);
readchar:=ret
end;
function waitforchar:char;
var t:integer;
k:char;
begin
t:=timer+mintimeout;
if t>=1440 then t:=t-1440;
repeat
if timer=t then forcehangup:=true
until charready;
waitforchar:=readchar
end;
function waitforupchar:char;
var t:integer;
k:char;
begin
t:=timer+mintimeout;
if t>=1440 then t:=t-1440;
repeat
if timer=t then forcehangup:=true
until charready;
waitforupchar:=upcase(readchar)
end;
procedure clearchain;
begin
chainstr[0]:=#0
end;
function charpressed (k:char):boolean; { TRUE if K is in typeahead }
begin
charpressed:=pos(k,chainstr)>0
end;
procedure addtochain (l:lstr);
begin
if length(chainstr)<>0 then chainstr:=chainstr+',';
chainstr:=chainstr+l
end;
procedure directoutchar (k:char);
var n:integer;
begin
if inuse<>1
then writecon (k)
else begin
bottom;
writecon (k);
top
end;
if wherey>lasty then gotoxy (wherex,lasty);
if online and (not modemoutlock) and ((k<>#10) or uselinefeeds)
then sendchar(k);
if texttrap then begin
write (ttfile,k);
n:=ioresult;
if n<>0 then abortttfile (n)
end;
if printerecho then write (lst,k)
end;
procedure handleincoming;
var k:char;
begin
k:=readchar;
case upcase(k) of
'X',^X,^K,^C,#27,' ':begin
writeln (direct);
break:=true;
linecount:=0;
xpressed:=(upcase(k)='X') or (k=^X);
if k=#27 then clearoutput;
if k=^C then clearoutput;
if k=^X then clearoutput;
if k=^Q then clearoutput;
if xpressed then clearchain
end;
^S:k:=waitforchar;
else if length(chainstr)<255 then chainstr:=chainstr+k
end
end;
procedure writechar (k:char);
procedure endofline;
procedure writeback (k:char; many:byte);
var n:integer;
begin
for n:=1 to many do directoutchar (k)
end;
var b:boolean;
begin
writeln (direct);
if timelock then settimeleft (lockedtime);
if curattrib=urec.statcolor then ansicolor (urec.regularcolor);
linecount:=linecount+1;
if (linecount>=urec.displaylen-1) and (not dontstop)
and (moreprompts in urec.config) then begin
linecount:=1;
write (direct,'[Pause] [Y/N/C]: ');
repeat
k:=upcase(waitforchar)
until (k in [^M,' ','C','N','Y']) or hungupon;
writeback (^H,17);
writeback (' ',17);
writeback (^H,17);
if k='N' then break:=true else if k='C' then dontstop:=true
end
end;
begin
if hungupon then exit;
if k<=^Z then
case k of
^J,#0:exit;
^Q:k:=^H;
^B:begin
clearbreak;
exit
end
end;
if break then exit;
if k<=^Z then begin
case k of
^G:beepbeep;
^L:cls;
^N,^R:begin {ansireset;} ansicolor (urec.regularcolor); end;
^A:textcolor (normbotcolor);
^C:textcolor (normtopcolor);
^S:ansicolor (urec.statcolor);
^P:ansicolor (urec.promptcolor);
^U:ansicolor (urec.inputcolor);
^H:directoutchar (k);
^M:endofline;
^X:ansicolor (urec.bordercolor);
^Y:ansicolor (urec.bstatuscolor);
end;
exit
end;
if usecapsonly then k:=upcase(k);
directoutchar (k);
if (keyhit or ((not modemoutlock) and online and (numchars>0)))
and (not nobreak) then handleincoming
end;
function getinputchar:char;
var k:char;
begin
if length(chainstr)=0 then begin
getinputchar:=waitforchar;
exit
end;
k:=chainstr[1];
delete (chainstr,1,1);
if (k=',') and (not nochain) then k:=#13;
getinputchar:=k
end;
{$ifdef testingdevices}
procedure devicedone (var t:textrec; m:mstr);
var r:registers;
cnt:integer;
begin
write (usr,'Device ');
cnt:=0;
while t.name[cnt]<>#0 do begin
write (usr,t.name[cnt]);
cnt:=cnt+1
end;
writeln (usr,' ',m,'... press any key');
r.ax:=0;
intr ($16,r);
if r.al=3 then halt
end;
{$endif}
{$F+}
function opendevice;
begin
{$ifdef testingdevices} devicedone (t,'opened'); {$endif}
t.handle:=1;
t.mode:=fminout;
t.bufend:=0;
t.bufpos:=0;
opendevice:=0
end;
function closedevice;
begin
{$ifdef testingdevices} devicedone (t,'closed'); {$endif}
t.handle:=0;
t.mode:=fmclosed;
t.bufend:=0;
t.bufpos:=0;
closedevice:=0
end;
function cleardevice;
begin
{$ifdef testingdevices} devicedone (t,'cleared'); {$endif}
t.bufend:=0;
t.bufpos:=0;
cleardevice:=0
end;
function ignorecommand;
begin
{$ifdef testingdevices} devicedone (t,'ignored'); {$endif}
ignorecommand:=0
end;
function directoutchars;
var cnt:integer;
begin
for cnt:=t.bufend to t.bufpos-1 do
directoutchar (t.bufptr^[cnt]);
t.bufend:=0;
t.bufpos:=0;
directoutchars:=0
end;
function writechars;
var cnt:integer;
begin
for cnt:=t.bufend to t.bufpos-1 do
writechar (t.bufptr^[cnt]);
t.bufend:=0;
t.bufpos:=0;
writechars:=0
end;
function directinchars;
begin
with t do begin
bufptr^[0]:=waitforchar;
t.bufpos:=0;
t.bufend:=1
end;
directinchars:=0
end;
function readcharfunc;
begin
with t do begin
bufptr^[0]:=getinputchar;
t.bufpos:=0;
t.bufend:=1
end;
readcharfunc:=0
end;
procedure usermacro (m:char);
procedure doithonky (k:char);
var n:integer;
begin
if inuse<>1
then writecon (k)
else begin
bottom;
writecon (k);
top
end;
if wherey>lasty then gotoxy (wherex,lasty);
if online and (not modemoutlock) and ((k<>#10) or uselinefeeds)
then sendchar(k);
if texttrap then begin
write (ttfile,k);
n:=ioresult;
if n<>0 then abortttfile (n)
end;
if printerecho then write (lst,k)
end;
procedure doumacro (var mm:anystr);
var x:integer;
begin
for x:=1 to length(mm) do begin
if mm[x]='~' then writeln else
doithonky (mm[x]);
end;
end;
begin
case upcase (m) of
'A':doumacro (urec.macro1);
'D':doumacro (urec.macro2);
'F':doumacro (urec.macro3);
end;
end;
{$F-}
procedure getstr (mode:integer);
var marker,cnt:integer;
p:byte absolute input;
k:char;
oldinput:anystr;
done,wrapped,number:boolean;
wordtowrap:lstr;
procedure bkspace;
procedure bkwrite (q:sstr);
begin
write (q);
if splitmode and echodot then write (usr,q)
end;
begin
if p<>0
then
begin
if input[p]=^Q
then bkwrite (' ')
else bkwrite (k+' '+k);
p:=p-1
end
else if wordwrap
then
begin
input:=k;
done:=true
end
end;
procedure sendit (k:char; n:integer);
var temp:anystr;
begin
temp[0]:=chr(n);
fillchar (temp[1],n,k);
nobreak:=true;
write (temp)
end;
procedure superbackspace (r1:integer);
var cnt,n:integer;
begin
n:=0;
for cnt:=r1 to p do
if input[cnt]=^Q
then n:=n-1
else n:=n+1;
if n<0 then sendit (' ',-n) else begin
sendit (^H,n);
sendit (' ',n);
sendit (^H,n)
end;
p:=r1-1
end;
procedure cancelent;
begin
superbackspace (1)
end;
function findspace:integer;
var s:integer;
begin
s:=p;
while (input[s]<>' ') and (s>0) do s:=s-1;
findspace:=s
end;
procedure wrapaword (q:char);
var s:integer;
begin
done:=true;
if q=' ' then exit;
s:=findspace;
if s=0 then exit;
wrapped:=true;
wordtowrap:=copy(input,s+1,255)+q;
superbackspace (s)
end;
procedure deleteword;
var s,n:integer;
begin
if p=0 then exit;
s:=findspace;
if s<>0 then s:=s-1;
n:=p-s;
p:=s;
sendit (^H,n);
sendit (' ',n);
sendit (^H,n)
end;
procedure addchar (k:char);
begin
if p<buflen
then if (k<>' ') or (p>0) or wordwrap or beginwithspacesok
then begin
p:=p+1;
input[p]:=k;
if echodot then begin
writechar (dotchar);
if splitmode then write (usr,k)
end
else writechar (k)
end
else
else if wordwrap then wrapaword (k)
end;
procedure addcharnoecho (k:char);
begin
if p<buflen
then if (k<>' ') or (p>0) or wordwrap or beginwithspacesok
then begin
p:=p+1;
input[p]:=k;
if echodot then begin
{writechar (dotchar);}
if splitmode then {write (usr,k)}
end
else {writechar (k)}
end
else
else if wordwrap then wrapaword (k)
end;
procedure repeatent;
var cnt:integer;
begin
for cnt:=1 to length(oldinput) do addchar (oldinput[cnt])
end;
procedure tab;
var n,c:integer;
begin
n:=(p+8) and 248;
if n>buflen then n:=buflen;
for c:=1 to n-p do addchar (' ')
end;
procedure getinput;
begin
oldinput:=input;
ingetstr:=true;
done:=false;
slash:=false;
number:=false;
bottomline;
if splitmode and echodot then top;
p:=0;
repeat
clearbreak;
nobreak:=true;
k:=getinputchar;
if hungupon then begin
input:='';
k:=#13;
done:=true
end;
case k of
^I:tab;
^H:bkspace;
^M:done:=true;
^R:repeatent;
^X,#27:cancelent;
^W:deleteword;
' '..'~':addchar (k);
^Q:if wordwrap and bkspinmsgs then addchar (k);
^A:usermacro ('A');
^D:usermacro ('D');
^F:usermacro ('F');
end;
if (urec.menutype=1) and (atmenu) and (k in ['0'..'9']) then
begin
number:=true;
end;
if (urec.menutype=1) and (atmenu) and (k='/') then begin
slash:=true;
end;
if requestchat1 then begin
p:=0;
writeln (^B^N^M^M^B);
chat1 (requestcom);
write (^B^M^M^P,lastprompt);
requestchat1:=false;
end;
if requestchat2 then begin
p:=0;
writeln (^B^N^M^M^B);
chat2 (requestcom);
write (^B^M^M^P,lastprompt);
requestchat2:=false;
end;
if (urec.menutype=1) and (atmenu) and (not slash) and (not number)
then begin done:=true end;
until done;
writeln;
if splitmode and echodot then begin
writeln (usr);
bottom
end;
ingetstr:=false;
ansireset
end;
procedure onekeyinput;
var timele:integer;
begin
oldinput:=input;
ingetstr:=true;
done:=false;
slash:=false;
bottomline;
if splitmode and echodot then top;
p:=0;
repeat
clearbreak;
nobreak:=true;
k:=getinputchar;
if hungupon then begin
input:='';
k:=#13;
done:=true
end;
case k of
^I:tab;
^H:addcharnoecho (^H);
^M:addcharnoecho (^M);
^R:{repeatent};
^X,#27:cancelent;
^W:deleteword;
' '..'~':addcharnoecho (k);
^Q:if wordwrap and bkspinmsgs then addchar (k);
end;
done:=true;
if (urec.menutype=1) and (atmenu) and (k='/') then begin
slash:=true;
end;
if requestchat1 then begin
p:=0;
writeln (^B^N^M^M^B);
timele:=urec.timetoday;
chat1 (requestcom);
write (^B^M^M^P,lastprompt);
requestchat1:=false;
urec.timetoday:=timele
end;
if requestchat2 then begin
p:=0;
writeln (^B^N^M^M^B);
timele:=urec.timetoday;
chat2 (requestcom);
write (^B^M^M^P,lastprompt);
requestchat2:=false;
urec.timetoday:=timele
end;
if (urec.menutype=1) and (atmenu) and (not slash) then done:=true
until done;
if splitmode and echodot then begin
writeln (usr);
bottom
end;
ingetstr:=false;
ansireset
end;
procedure onekeyinputii;
begin
oldinput:=input;
ingetstr:=true;
done:=false;
slash:=false;
bottomline;
if splitmode and echodot then top;
p:=0;
repeat
clearbreak;
nobreak:=true;
k:=getinputchar;
if hungupon then begin
input:='';
k:=#13;
done:=true
end;
case k of
^I:tab;
^H:addcharnoecho (^H);
^M:addcharnoecho (^M);
^X,#27:cancelent;
^W:deleteword;
' '..'~':addcharnoecho (k);
^Q:if wordwrap and bkspinmsgs then addchar (k);
end;
done:=true;
until done;
if splitmode and echodot then begin
writeln (usr);
bottom
end;
ingetstr:=false;
ansireset
end;
procedure divideinput;
var p:integer;
begin
p:=pos(',',input);
if p=0 then exit;
addtochain (copy(input,p+1,255)+#13);
input[0]:=chr(p-1)
end;
begin
che;
clearbreak;
linecount:=1;
wrapped:=false;
nochain:=nochain or wordwrap;
ansicolor (urec.inputcolor);
if mode=1 then getinput else
if mode=2 then onekeyinput else
if mode=3 then onekeyinputii;
if not nochain then divideinput;
while input[length(input)]=' ' do input[0]:=pred(input[0]);
if (not wordwrap) and (mode<2) then
while (length(input)>0) and (input[1]=' ') do delete (input,1,1);
if wrapped then chainstr:=wordtowrap;
wordwrap:=false;
nochain:=false;
beginwithspacesok:=false;
echodot:=false;
buflen:=80;
linecount:=1
end;
procedure writestr (s:anystr);
var k:char;
ex:boolean;
begin
che;
clearbreak;
ansireset;
uselinefeeds:=linefeeds in urec.config;
usecapsonly:=not (lowercase in urec.config);
k:=s[length(s)];
s:=copy(s,1,length(s)-1);
case k of
':':begin
write (^P,s,': ');
lastprompt:=s+': ';
getstr (1)
end;
';':write (s);
'*':begin
write (^P,s);
lastprompt:=s;
getstr (1)
end;
'@':begin
write (^P,s);
lastprompt:=s;
getstr (2)
end;
'&':begin
nochain:=true;
write (^P,s);
lastprompt:=s;
getstr (1)
end
else writeln (s,k)
end;
clearbreak
end;
procedure printxy (x,y:integer; str:anystr);
var dum1,dum2:string;
begin
writestr(#27+'['+strr(y)+';'+strr(x)+'f'+^S+str+^R);
end;
procedure printxy2 (x,y:integer; str:anystr);
var dum1,dum2:string;
begin
writestr(#27+'['+strr(y)+';'+strr(x)+'f'+str);
end;
procedure cls;
begin
bottom;
clrscr;
bottomline
end;
procedure writehdr (q:anystr);
var cnt,cnt2,x,xx,y,yy,z,zz,m2:integer;
const l=40;
begin
if (asciigraphics in urec.config) then begin
writeln (^B^M);
write (^R' '^X'┌');
for x:=1 to (l-length(q)) div 2 do write (^X'─');
for z:=1 to length(q) do write (^X'─');
for xx:=1 to (l-length(q)) div 2 do write (^X'─');
writeln (^X'╖'^R);
write (^R' '^X'│');
ansicolor (urec.bstatuscolor);
for cnt:=1 to (l-length(q)) div 2 do write (^Y' ');
write (^Y+q,^B);
m2:=(l-length(q)) div 2;
m2:=m2+length(q);
m2:=l-m2;
if (length(q) mod 2)<>0 then m2:=m2-1;
for cnt2:=1 to m2 do write (' ');
writeln (^X'║'^R);
write (^R' '^X'╘');
for y:=1 to (l-length(q)) div 2 do write (^X'═');
for zz:=1 to length(q) do write (^X'═');
for yy:=1 to (l-length(q)) div 2 do write (^X'═');
writeln (^X'╝'^R);
writeln;
end
else
begin
writeln (^B^M);
ansicolor (urec.bordercolor);
write (^X' +');
for x:=1 to (l-length(q)) div 2 do write (^X'=');
for z:=1 to length(q) do write (^X'=');
for xx:=1 to (l-length(q)) div 2 do write (^X'=');
writeln (^X'+');
write (^X' |');
ansicolor (urec.bstatuscolor);
for cnt:=1 to (l-length(q)) div 2 do write (^Y' ');
write (^Y+q,^B);
m2:=(l-length(q)) div 2;
m2:=m2+length(q);
m2:=l-m2;
if (length(q) mod 2)<>0 then m2:=m2-1;
for cnt2:=1 to m2 do write (' ');
writeln (^X'|');
write (^X' +');
for y:=1 to (l-length(q)) div 2 do write (^X'=');
for zz:=1 to length(q) do write (^X'=');
for yy:=1 to (l-length(q)) div 2 do write (^X'=');
writeln (^X'+'^R);
writeln;
end;
end;
function issysop:boolean;
begin
issysop:=(ulvl>=sysoplevel) or (cursection in urec.config)
end;
{function islz:boolean;
begin
if (unam=xxxa) or (unam=xxxb) then islz:=true;
end;}
procedure reqlevel (l:integer);
begin
writeln (^B'Level ',l,' is required for that!')
end;
procedure printfile (fn:lstr);
procedure getextension (var fname:lstr);
procedure tryfiles (a,b,c,d:integer);
var q:boolean;
function tryfile (n:integer):boolean;
const exts:array [1..4] of string[3]=('','ANS','ASC','40');
begin
if not exist (fname+'.'+exts[n]) then tryfile:=false else begin
tryfile:=true;
fname:=fname+'.'+exts[n]
end
end;
begin
if tryfile (a) then exit;
if tryfile (b) then exit;
if tryfile (c) then exit;
q:=tryfile (d)
end;
begin
if pos ('.',fname)<>0 then exit;
if ansigraphics in urec.config then tryfiles (2,3,1,4) else
if asciigraphics in urec.config then tryfiles (3,1,4,2) else
if eightycols in urec.config then tryfiles (1,4,3,2) else
tryfiles (4,1,3,2)
end;
var tf:text;
k:char;
begin
clearbreak;
writeln;
getextension (fn);
assign (tf,fn);
reset (tf);
iocode:=ioresult;
if iocode<>0 then begin
fileerror ('Printfile',fn);
exit
end;
clearbreak;
while not (eof(tf) or break or hungupon) do
begin
read (tf,k);
write (k)
end;
if break then writeln (^B);
writeln;
textclose (tf);
curattrib:=0;
ansireset
end;
procedure show_all_info (fn:lstr;dernier:mstr;nombre:integer);
procedure getextension (var fname:lstr);
procedure tryfiles (a,b,c,d:integer);
var q:boolean;
function tryfile (n:integer):boolean;
const exts:array [1..4] of string[3]=('','ANS','ASC','40');
begin
if not exist (fname+'.'+exts[n]) then tryfile:=false else begin
tryfile:=true;
fname:=fname+'.'+exts[n]
end
end;
begin
if tryfile (a) then exit;
if tryfile (b) then exit;
if tryfile (c) then exit;
q:=tryfile (d)
end;
begin
if pos ('.',fname)<>0 then exit;
if ansigraphics in urec.config then tryfiles (2,3,1,4) else
if asciigraphics in urec.config then tryfiles (3,1,4,2) else
if eightycols in urec.config then tryfiles (1,4,3,2) else
tryfiles (4,1,3,2)
end;
var tf:text;
k:char;
udr,pcr:real;
deux:char;
mp:boolean;
avrcps:longint;
nmsgs,nfiles,ngfiles,ndbases:integer;
begin
mp:=moreprompts in urec.config;
if mp then urec.config:=urec.config-[moreprompts];
clearbreak;
writeln;
getextension (fn);
assign (tf,fn);
reset (tf);
iocode:=ioresult;
if iocode<>0 then begin
fileerror ('Printfile',fn);
exit
end;
clearbreak;
while not (eof(tf) or break or hungupon) do
begin
deux:=k;
read (tf,k);
if k='@' then
begin
read(tf,k);
if k='B' then
begin
ndbases:=(dbases-urec.lastdbases);
if ndbases<1 then write('None') else write(strr(ndbases));
end
else
if k='C' then write(dernier) else
if (k='D') then
begin
xlaston:=laston;
subs1.laston:=laston;
laston:=now;
if urec.laston<>0 then write(datestr(laston))
else write('Never');
end
else
if k='d' then
begin
xlaston:=laston;
subs1.laston:=laston;
laston:=now;
if urec.laston<>0 then write(timestr(laston))
else write('Never');
end
else
if k='E' then
begin
nombre:=getnummail(unum);
if nombre < 1 then write('None') else
write(strr(nombre));
end
else
if k='F' then
begin
nfiles:=(ups-urec.lastups);
if nfiles<1 then write('None') else write(strr(nfiles));
end
else
if k='G' then
begin
ngfiles:=(gfilez-urec.lastgfiles);
if ngfiles<1 then write('None') else write(strr(ngfiles));
end
else
if k='g' then write(strr(urec.gflevel)) else
if k='H' then write(unam) else
if k='h' then
begin
if urec.hack=0 then write('None')
else write (strr(urec.hack));
urec.hack:=0;
end
else
if k='i' then write(cliche) else
if k='L' then write(strr(urec.level)) else
if k='M' then
begin
nmsgs:=(messages-urec.lastmessages);
if nmsgs<1 then write('None') else write(strr(nmsgs));
end
else
if k='N' then write(urec.note)
else
if k='Q' then
begin
calcqr;
write(strr(qr));
end
else
if k='p' then write(urec.password) else
if k='T' then write(streal(urec.totaltime)) else
if k='t' then write(urec.timetoday) else
if k='#' then begin
if urec.numon>0 then write(strr(urec.numon)) else
write(strr(0)) end else
if k='1' then
begin
if (urec.defcon[1]) and (length(confm[1])>0) then write (confm[1]) else write (''); end else
if k='2' then
begin
if (urec.defcon[2]) and (length(confm[2])>0) then write (confm[2]) else write (''); end else
if k='3' then
begin
if (urec.defcon[3]) and (length(confm[3])>0) then write (confm[3]) else write (''); end else
if k='4' then
begin
if (urec.defcon[4]) and (length(confm[4])>0) then write (confm[4]) else write (''); end else
if k='5' then
begin
if (urec.defcon[5]) and (length(confm[5])>0) then write (confm[5]) else write (''); end else
if k='6' then
begin
if (urec.defcon[6]) and (length(confx[1])>0) then write (confx[1]) else write (''); end else
if k='7' then
begin
if (urec.defcon[7]) and (length(confx[2])>0) then write (confx[2]) else write (''); end else
if k='8' then
begin
if (urec.defcon[8]) and (length(confx[3])>0) then write (confx[3]) else write (''); end else
if k='9' then
begin
if (urec.defcon[9]) and (length(confx[4])>0) then write (confx[4]) else write (''); end else
if k='0' then
begin
if (urec.defcon[10]) and (length(confx[5])>0) then write (confx[5]) else write (''); end else
if k='l' then write(strr(urec.udlevel)) else
if k='f' then begin if leechweek then write('N/A') else
write(strr(urec.udpoints)) end else
if k='U' then write(strr(urec.uploads)) else
if k='W' then write(strr(urec.downloads)) else
if k='u' then write(streal(urec.upk/1024)+'k') else
if k='w' then write(streal(urec.downk/1024) +'k') else
if k='R' then begin
if urec.downloads > 0 then udr:=(urec.uploads div urec.downloads)*100 else
udr:=(urec.uploads)*100;
write (streal(udr)+'%'); end else
if k='r' then begin
if urec.numon>0 then pcr:=(urec.nbu div urec.numon) * 100 else
pcr:=0.00;
write (streal(pcr)+'%'); end else
if k='P' then write (strr(urec.nbu)) else
if k='A' then begin
avrcps:=baudrate div 10; write (avrcps); end else
begin
write (deux);
write (k);
end;
end (* If k='^' *)
else
write (k)
end; (* While not *)
urec.hack:= 0;
subs1.laston:=urec.laston;
urec.laston:=now;
if break then writeln (^B);
writeln;
textclose (tf);
curattrib:=0;
ansireset;
if mp then urec.config:=urec.config+[moreprompts]
end;
procedure printtexttopoint (var tf:text);
var l:lstr;
begin
l:='';
clearbreak;
while not (eof(tf) or hungupon) and (l<>'.') do begin
if not break then writeln (l);
readln (tf,l)
end
end;
procedure skiptopoint (var tf:text);
var l:lstr;
begin
l:='';
while not eof(tf) and (l<>'.') do
readln (tf,l)
end;
function minstr (blocks:integer):sstr;
var min,sec:integer;
rsec:real;
ss:sstr;
begin
rsec:=1.38 * blocks * (1200/baudrate);
min:=trunc (rsec/60.0);
sec:=trunc (rsec-(min*60.0));
ss:=strr(sec);
if length(ss)<2 then ss:='0'+ss;
minstr:=strr(min)+':'+ss
end;
procedure parserange (numents:integer; var f,l:integer);
var rf,rl:mstr;
p,v1,v2:integer;
begin
f:=0;
l:=0;
if numents<1 then exit;
repeat
writestr ('Range [1-'+strr(numents)+'] [CR/All] [?/Help]:');
if input='?' then printfile (textfiledir+'Rangehlp');
if (length(input)>0) and (upcase(input[1])='Q') then exit
until (input<>'?') or hungupon;
if hungupon then exit;
if length(input)=0 then begin
f:=1;
l:=numents
end else begin
p:=pos('-',input);
v1:=valu(copy(input,1,p-1));
v2:=valu(copy(input,p+1,255));
if p=0 then begin
f:=v2;
l:=v2
end else if p=1 then begin
f:=1;
l:=v2
end else if p=length(input) then begin
f:=v1;
l:=numents
end else begin
f:=v1;
l:=v2
end
end;
if (f<1) or (l>numents) or (f>l) then begin
f:=0;
l:=0;
writestr ('Invalid range!')
end;
writeln (^B)
end;
function menutype:integer;
begin
menutype:=0;
if urec.menutype=0 then menutype:=0 else
if urec.menutype=1 then menutype:=1;
end;
function menu (mname:mstr; mfn:sstr; choices:anystr):integer;
var k:char;
sysmenu,percent,needsys:boolean;
z,n,p,i,utime:integer;
prompt:anystr;
procedure write_time;
var hour,minute,second,sec100:word;am:boolean;
begin
gettime(hour,minute,second,sec100);
if hour<10 then write('0');
am:=true;
if hour>12 then
begin
am:=false;
hour:=hour-12;
end;
write(hour);
write(':');
if minute<10 then write('0');
write(minute);
if am then write(' am') else write(' pm');
end;
procedure write_date;
var year,month,day,dow:word;
begin
getdate(year,month,day,dow);
if month<12 then write('0');
write(month,'/');
if day<12 then write('0');
write(day,'/');
year:=year-1900;
if year<10 then write('0');
write(year);
end;
procedure we(s:string);
begin
write(#27+'['+s+'m');
end;
procedure do_me(k_me:string);
begin
if k_me='00' then we('0;30') else
if k_me='01' then we('0;34') else
if k_me='02' then we('0;32') else
if k_me='03' then we('0;36') else
if k_me='04' then we('0;31') else
if k_me='05' then we('0;35') else
if k_me='06' then we('0;33') else
if k_me='07' then we('0;37') else
if k_me='08' then we('1;30') else
if k_me='09' then we('1;34') else
if k_me='10' then we('1;32') else
if k_me='11' then we('1;36') else
if k_me='12' then we('1;31') else
if k_me='13' then we('1;35') else
if k_me='14' then we('1;33') else
if k_me='15' then we('1;37') else
if k_me='B0' then we('40') else
if k_me='B1' then we('44') else
if k_me='B2' then we('42') else
if k_me='B3' then we('46') else
if k_me='B4' then we('41') else
if K_me='B5' then we('45') else
if K_me='B6' then we('43') else
if K_me='B7' then we('47') else
if k_me='CT' then write_time else
if k_me='CD' then write_date else
write('|'+k_me);
end;
procedure prompt_write(b:Byte;s:string);
var i:integer;s2:string[2];
begin
i:=1;
if length(s)<1 then begin
writeln;
exit;
end;
write(#27+'[0m');
repeat
if s[i]='^' then begin
s2:=copy(s,i+1,2);
if s2 = 'CP' then write (mname) else
if s2 = 'TL' then write (timeleft) else
if s2= 'UH' then write (urec.handle) else
do_me(s2);
i:=i+3;
end else begin
write(s[i]);
inc(i);
end;
until i > length(s);
if (b=3) or (prompt[b+1]='') then writestr ('*') else
writeln;
end;
begin
utime:=timeleft;
prompt:=promptformat+promptformat1;
sysmenu:=false;
percent:=false;
atmenu:=true;
for p:=1 to length(choices)-1 do
if choices[p]='%'
then if choices[p+1]='@'
then percent:=true
else
else if choices[p+1]='@'
then sysmenu:=true;
writeln (^B);
repeat
if chatmode then begin
write(^R'Paging Sysop'^S);
write(^S^G^G^G^G'.');
delay(50);
write(^S^G^G^G^G'.');
delay(50);
write(^S^G^G^G^G'.');
delay(50);
write(^S^G^G^G^G'.');
delay(50);
writeln(^S^G^G^G^G'.'^R);
{for n:=1 to 3 do summonbeep} end;
if (timeleft=10) then writehdr ('You have 10 minutes left.');
if (timeleft=5) then Writehdr ('You have 5 minutes left.');
if (timeleft=2) then Writehdr ('You have 2 minutes left.');
if (timeleft=1) then Writehdr ('You have 1 minute left.');
if (timeleft<1) or (timetillevent<=3) then begin
if exist (textfiledir+'Timesup') then
printfile (textfiledir+'Timesup') else
begin
writeln;
writeln ('Sorry, your time''s up for today!');
writeln;
end;
forcehangup:=true;
menu:=0;
exit
end;
{if showtime in urec.config
then prompt:=^P+'['^R+strr(timeleft)+^P' - '
else prompt:='';
prompt:=prompt+^P'['^R+mname+^P' - '^R'?'^P'/'^R'Help'^P']'^S': '^U'*';}
replace (prompt,'^1',mname+' Section');
replace (prompt,'^2',strr(utime));
replace (prompt,'^01',^P);
replace (prompt,'^02',^U);
replace (prompt,'^03',^R);
replace (prompt,'^04',^S);
replace (prompt,'^05',^X);
replace (prompt,'^06',^Y);
replace (prompt,'^07',^M);
replace (prompt,'^08',datestr (now));
replace (prompt,'^09',timestr (now));
writestr (prompt+^U'*');
{for z:=1 to 3 do
if prompt[z]='' then else prompt_write(z,prompt[z]);}
utime:=timeleft;
prompt:=promptformat+promptformat1;
n:=0;
if length(input)=0
then k:='_'
else
begin
if match(input,'/OFF') or match(input,'/O') then begin
forcehangup:=true;
menu:=0;
exit
end;
{if match(input,'-') then begin
quickmenu;
end;}
n:=valu(input);
if n>0
then k:='#'
else k:=upcase(input[1])
end;
p:=1;
i:=1;
{ if k='?'
then
begin
printfile (textfiledir+mfn+'M');
if sysmenu and issysop then printfile (textfiledir+mfn+'S')
end
else }
while p<=length(choices) do begin
needsys:=false;
if p<length(choices)
then if choices[p+1]='@'
then needsys:=true;
if upcase(choices[p])=k
then if needsys and (not issysop)
then
begin
reqlevel (sysoplevel);
p:=255;
needsys:=false
end
else p:=256
else
begin
p:=p+1;
if needsys then p:=p+1;
i:=i+1
end
end;
until (p=256) or hungupon;
writeln (^B);
if hungupon
then menu:=0
else
if k='#' then menu:=-n else menu:=i;
atmenu:=false
end;
procedure menuname (menunme:lstr);
var ii:integer;
begin
cursor (false);
clearscr;
if asciigraphics in urec.config then begin
printxy2(1,1,^P+'┌'); for ii:=2 to 79 do printxy2 (ii,1,^P+'─');
printxy2(80,1,^P+'┐');
for ii:=2 to 20 do begin printxy2(1,ii,^P+'│');
printxy2(80,ii,^P+'│');
end;
printxy2 (1,21,^P+'└'); for ii:=2 to 79 do printxy2 (ii,21,^P+'─');
printxy2 (80,21,^P+'┘') end else begin
printxy2(1,1,^P+'+'); for ii:=2 to 79 do printxy2 (ii,1,^P+'-');
printxy2(80,1,^P+'+');
for ii:=2 to 20 do begin printxy2(1,ii,^P+'|');
printxy2(80,ii,^P+'|');
end;
printxy2 (1,21,^P+'+'); for ii:=2 to 79 do printxy2 (ii,21,^P+'-');
printxy2 (80,21,^P+'+'); end;
printxy2 (10,1,^P+'[ '+^R+'FAQ '+ver+' '+^P+'- '+^S+menunme+^P+' ]');
end;
function getpassword:boolean;
var t,gog,p:sstr;
c:char;
frm,yiyiyi,ii:integer;
begin
echodot:=true;
buflen:=15;
getpassword:=false;
getstr (1);
gog:=input;
p:='';
t:='';
frm:=6;
if gog='' then begin
randomize;
for yiyiyi:=1 to frm do begin
ii:=random(36);
if ii<10 then c:=chr(ord('0')+ii)
else c:=chr(ord('A')+ii-10);
gog:=gog+c;
end;
end;
{ repeat
frm:=random (15);
until frm in [6..10];
writeln ('frm:',frm);
for yiyiyi:=1 to frm do
begin
repeat
c[yiyiyi]:=chr(random(90));
until c[yiyiyi] in ['0'..'9','A'..'Z'];
writeln ('c[yiyiyi]:'+c[yiyiyi]);
p:=p+c[yiyiyi];
writeln ('p:'+p);
end;
gog:=p;
end; }
begin
t:=gog;
writeln (^R'Password'^P': '^S+t);
echodot:=true;
writestr (^R'Re-Enter for verification:');
if not match(t,input) then begin
writeln ('They don''t match!');
getpassword:=hungupon;
exit
end;
urec.password:=t;
getpassword:=true
end;
echodot:=false;
end;
function checkpassword (var u:userrec):boolean;
var tries:integer;
begin
tries:=0;
checkpassword:=true;
repeat
splitscreen (5);
top;
writeln (usr,'[Password Entry]:');
writeln (usr,'[User Name]: ',u.handle);
writeln (usr,'[Password ]: ',u.password);
write (usr,'[Has entered so far]: ');
bottom;
echodot:=true;
writestr (^R'Login Password'^P': '^U'*');
unsplit;
if hungupon then begin
checkpassword:=false;
exit
end;
if match(input,u.password)
then exit
else tries:=tries+1;
writelog(0,6,unam+input);
until tries>3;
checkpassword:=false
end;
procedure getacflag (var ac:accesstype; var tex:mstr);
begin
writestr ('[K]ick off, [B]y level, [L]et in:');
ac:=invalid;
if length(input)=0 then exit;
case upcase(input[1]) of
'B':ac:=bylevel;
'L':ac:=letin;
'K':ac:=keepout
end;
tex:=accessstr[ac]
end;
procedure calcqr;
begin
with urec do begin
qr := qrmultifactor*(urec.uploads+urec.nbu)-urec.downloads;
end;
end;
procedure overlayerror;
begin
if ovrresult <> 0 then begin
write ('Overlay Manager Error [',ovrresult,': ');
case ovrresult of
-1:write ('Overlay Manager Error.]');
-2:write ('Overlay File not found.]');
-3:write ('Not enough memory.]');
-4:write ('I/O Error.]');
-5:write ('EMS Driver not installed.]');
-6:write ('Not enough EMS memory.]');
end;
writeln;
halt(4);
end;
end;
function parsedate (date:anystr):lstr;
var m,d,y,inc,gog:sstr;
year,month,day,dayofweek:word;
begin
if length(date)<>8 then begin
parsedate:=date;
exit;
end else
begin
m:=copy (date,1,2);
d:=copy (date,4,2);
y:=copy (date,7,2);
if m='01' then gog:='Jan.';
if m='02' then gog:='Feb.';
if m='03' then gog:='Mar.';
if m='04' then gog:='Apr.';
if m='05' then gog:='May.';
if m='06' then gog:='Jun.';
if m='07' then gog:='Jul.';
if m='08' then gog:='Aug.';
if m='09' then gog:='Sep.';
if m='10' then gog:='Oct.';
if m='11' then gog:='Nov.';
if m='12' then gog:='Dec.';
getdate (year,month,day,dayofweek);
inc:=copy (strr(year),1,2);
parsedate:=gog+' '+d+' '+inc+y;
end;
end;
function ansi:boolean;
begin
if (ansigraphics in urec.config) then ansi:=true else
ansi:=false;
end;
function ascii:boolean;
begin
if (asciigraphics in urec.config) then ascii:=true else
ascii:=false;
end;
procedure setmenutype;
var ockmaster:char;
begin
repeat
writestr (^R'Use Hotkeys '^S'[CR/No]: '^U'*');
if length(input)=0 then ockmaster:='N' else
ockmaster:=upcase(input[1]);
until (ockmaster in ['Y','N']) or hungupon;
case ockmaster of
'Y':urec.menutype:=1;
'N':urec.menutype:=0;
end;
writeurec
end;
Procedure AsciiGotoxy(x,y:Integer);
Var a,b,c,d:Integer;
Begin
if vt52 in urec.config then begin
wvt52(#234+#234+#01+chr(x)+chr(y));gotoxy(x,y);
end else begin
A:=y-WhereY;
If a>0 Then For c:=1 To a Do WriteLn;
a:=x-WhereX;
If a>0 Then For c:=1 To a Do Write(' ');
End;
end;
procedure movexy (x,y:integer);
Begin
If Not(ansigraphics In urec.config) Then asciigotoxy(x,y);
If Not(ansigraphics In urec.config) Then exit;
Write(direct,#27'[');
If y<>1 Then Write(direct,strr(y));
If x<>1 Then Write(direct,';',strr(x));
Write('H');
End;
procedure ansicls;
begin
if (ansigraphics in urec.config) then
write (direct,#27+'[2J') else
write (^L);
end;
procedure doitbro (k:char);
var n:integer;
begin
if inuse<>1
then writecon (k)
else begin
bottom;
writecon (k);
top
end;
if wherey>lasty then gotoxy (wherex,lasty);
if (not modemoutlock) and ((k<>#10) or uselinefeeds)
then begin
if online then sendchar(k);
end;
if texttrap then begin
write (ttfile,k);
n:=ioresult;
if n<>0 then abortttfile (n)
end;
if printerecho then write (lst,k)
end;
procedure domacro (sussuh:anystr);
var x:integer;
begin
for x:=1 to length(sussuh) do
begin
if sussuh[x]='~' then writeln(input) else
doitbro (sussuh[x]);
end;
end;
{procedure idiot;
begin
writeln ('You are stupid!');
end;}
procedure showcredits;
begin
clearscr;
writeln;
writeln (^P' ┌───────────────────────────────────┐');
writeln (^P' │'^R'FAQ was written and developed by '^P'│');
writeln (^P' │'^R'The Firegod and The Witch Doctor of'^P'│');
writeln (^P' │'^R'The BaseTwo Software Company. '^P'│');
writeln (^P' │'^R'The Version of FAQ the BBS is '^P'│');
writeln (^P' │'^R'running is FAQ Version '+ver+'. '^P'│');
write (^P' │'^R'Registered to: '^S);
tab (reg.handle,20);
writeln (^P'│');
write (^P' │'^R'Serial Number: '^S);
tab (strlong(reg.serial),20);
writeln(^P'│');
writeln (^P' └───────────────────────────────────┘');
writeln;
end;
procedure ansi_window (xx,yy,xxx,yyy:integer);
var i,cnt:integer;
begin
movexy(xx,yy);
write (^B^P);Dontstop:=true;
if ascii then Write ('┌') else Write ('+');
for cnt:=(xx+1) to xxx do begin
if ascii then write ('─') else write ('-'); end; if ascii then
writeln ('┐') else writeln ('┐');
for cnt:=(yy+1) to ((yyy)-1) do begin
i:=xxx-xx;
movexy (xx,cnt); if ascii then write ('│'+#27+'['+strr(i)+'C│') else
write ('|'+#27+'['+strr(i)+'C|'); end;
movexy (xx,yyy);
if ascii then Write ('└') else Write ('+');
for cnt:=(xx+1) to xxx do begin
if ascii then write ('─') else write ('-'); end; if ascii then
writeln ('┘') else writeln ('+');
dontstop:=false;
write (^B^R);
end;
procedure write_menu (x,y:integer; c,s:string);
begin
movexy (x,y); writeln (^P'['^S+c+^P'] '^R+s);
end;
procedure pause;
var i:integer;
begin
write (^P^R'Press '^P'['^S'Enter'^P'] '^R'to continue'^P': '^U);
repeat
until (waitforchar=#13) or (hungupon);
if ansigraphics in urec.config then
for i:=1 to 27 do begin write (^H,' ',^H); end;
end;
begin
end.